COMMENT ⊗   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002
C00011 ENDMK
C⊗;

(de suins (l liees type) 
  ; L = une suite (e1 ... en) . On anaobe chaque ei ;
  ; type = T dans un PROG-body ;
  (while l (anaob (nextl l))))

(de anaob (l ;; x y) (cond
  ((numbp l))
  ((stringp l) (add l 'strings))
  ((atom l) (or type (voir l)))
  ((atom (setq x (car l)))
   ; function call ou clause-de-cond ;
   (setq y (cadr l))
   (selectq x
	((function quote) (and (listp y) (anaclause y liees)))
	       ; regle le cas des '(lambda ...) ;
	((newl setq) (voir y t) (anaob (caddr l)) 
	       (and (cdddr l) (anaob (cons 'setq (cdddr l)))))
	((incr decr) (voir y y))
	(setqq (voir y t) (and (cdddr l) 
			       (cons 'setq (cdddr l))))
	(setqa (voir y t) (suins (cddr l) liees))
	((lambda prog escape) (anaclause l liees))
	((go nil))
	(t (suins (cdr l) liees))
	((maparray maparrayq map mapc mapcar mapct maplist
          maps mapst mapsub mapt some every)
         (anaob (cadr l) liees) (anaclause (caddr l) liees))
	(maparrayq (voir y t) (anaclause (caddr l) liees))
	(apply (anaclause y liees) (anaob (caddr l) liees))
	(selectq  (anaob y liees) (setq x (cddr l))
		  (while (cdr x) (suins (cdr (nextl x)) liees))
		  (suins (nextl x) liees))
	(cond     (setq x (cdr l))
		  (while x (suins (nextl x) liees)))
	((de df dm dmi dmo dmc) (casecallform l)
			        (newl -lindex y)
				(anadef l))
	((cond
	   ((setq y (get x 'macro)) (anaob (apply y [l])))
	   ((numbp x))
	   ((or (standard x) (user x)) (suins (cdr l) liees))))))
  (t (suins l liees)) ))

(de voir (x y) 
  ; x : une possible variable libre ;
  ; y = T dans le cas de SETQ  ou de NEWL ou de INCR ou de DECR ;
  ;		   ou de SETQA  ou de MAPARRAYQ  ou de SETQQ ;
  (or (numbp x) (memq x '(t quote lambda expr fexpr macro nil))
      (memq x liees)
      (progn
        (and y (add x 'fvarset))
        (add x 'fvars))))

(de anaclause (l liees ;; x y)
  (if (atom l) (or (numbp l) (standard l) (user l))
      (setq x (car l) y (cadr l))
      (selectq x
	(quote (if (listp y) (anaclause y liees) 
		   (or (numbp y) (standard y) (user y))))
	(lambda (suins (cddr l) (append (and y (linear y)) liees)))
	(escape (suins (cddr l) (cons y liees)))
	(prog (suins (cddr l) (append y liees) t))
	())))

(de user (x) (or (memq x liees) (add x 'using)))

(de standard (f) (or (le (loc f) (loc 'stop))
		     (getl f '(expr fexpr macro macin macout))))


(de add (ob v) 
  (let ((val (eval v)))
    (or (memq ob val) (set v (cons ob val)))))